home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / regexp / regexp.lsp < prev    next >
Encoding:
Text File  |  1995-04-20  |  11.1 KB  |  315 lines
  1. ;; Module for regular expression searching/matching in CLISP
  2. ;; Bruno Haible 14.4.1995, 18.4.1995
  3.  
  4. (in-package "REGEXP")
  5.  
  6. (export '(match match-start match-end match-string regexp-quote))
  7.  
  8. (use-package "FFI")
  9.  
  10. ; Common OS definitions:
  11. (def-c-type size_t uint)
  12.  
  13. #|
  14. ; Intermediate types not actually exported by regex.h:
  15. (def-c-type reg_syntax_t uint)
  16. (def-c-struct re_pattern_buffer
  17.   (buffer c-pointer)
  18.   (allocated ulong)
  19.   (used ulong)
  20.   (syntax reg_syntax_t)
  21.   (fastmap c-pointer)
  22.   (translate c-pointer)
  23.   (re_nsub size_t)
  24.   (flags uint8)
  25. )
  26. (def-c-type %regex_t re_pattern_buffer)
  27. (eval-when (load compile eval) (defconstant sizeof-%regex_t (sizeof '%regex_t)))
  28. (def-c-type regex_t (c-array uchar #.sizeof-%regex_t))
  29. |#
  30. (def-c-type regex_t-ptr c-pointer)
  31.  
  32. ; Types exported by regex.h:
  33. (def-c-type regoff_t int)
  34. (def-c-struct regmatch_t
  35.   (rm_so regoff_t)
  36.   (rm_eo regoff_t)
  37. )
  38.  
  39. ;; Functions exported by regex.h:
  40.  
  41. #| ;; This documentation comes from regex.h and regex.c.
  42.  
  43. extern int regcomp (regex_t *preg, const char *pattern, int cflags);
  44.  
  45.    regcomp takes a regular expression as a string and compiles it.
  46.  
  47.    PREG is a regex_t *.  We do not expect any fields to be initialized,
  48.    since POSIX says we shouldn't.  Thus, we set
  49.  
  50.      `buffer' to the compiled pattern;
  51.      `used' to the length of the compiled pattern;
  52.      `syntax' to RE_SYNTAX_POSIX_EXTENDED if the
  53.        REG_EXTENDED bit in CFLAGS is set; otherwise, to
  54.        RE_SYNTAX_POSIX_BASIC;
  55.      `newline_anchor' to REG_NEWLINE being set in CFLAGS;
  56.      `fastmap' and `fastmap_accurate' to zero;
  57.      `re_nsub' to the number of subexpressions in PATTERN.
  58.  
  59.    PATTERN is the address of the pattern string.
  60.  
  61.    CFLAGS is a series of bits which affect compilation.
  62.  
  63.      If REG_EXTENDED is set, we use POSIX extended syntax; otherwise, we
  64.      use POSIX basic syntax.
  65.  
  66.      If REG_NEWLINE is set, then . and [^...] don't match newline.
  67.      Also, regexec will try a match beginning after every newline.
  68.  
  69.      If REG_ICASE is set, then we considers upper- and lowercase
  70.      versions of letters to be equivalent when matching.
  71.  
  72.      If REG_NOSUB is set, then when PREG is passed to regexec, that
  73.      routine will report only success or failure, and nothing about the
  74.      registers.
  75.  
  76.    It returns 0 if it succeeds, nonzero if it doesn't.  (See regex.h for
  77.    the return codes and their meanings.)
  78.  
  79.  
  80. extern int regexec (const regex_t *preg, const char *string, size_t nmatch,
  81.                     regmatch_t pmatch[], int eflags);
  82.  
  83.    regexec searches for a given pattern, specified by PREG, in the
  84.    string STRING.
  85.    
  86.    If NMATCH is zero or REG_NOSUB was set in the cflags argument to
  87.    `regcomp', we ignore PMATCH.  Otherwise, we assume PMATCH has at
  88.    least NMATCH elements, and we set them to the offsets of the
  89.    corresponding matched substrings.
  90.    
  91.    EFLAGS specifies `execution flags' which affect matching: if
  92.    REG_NOTBOL is set, then ^ does not match at the beginning of the
  93.    string; if REG_NOTEOL is set, then $ does not match at the end.
  94.    
  95.    We return 0 if we find a match and REG_NOMATCH if not.
  96.  
  97.  
  98. extern size_t regerror (int errcode, const regex_t *preg,
  99.                         char *errbuf, size_t errbuf_size);
  100.  
  101.    Returns a message corresponding to an error code, ERRCODE, returned
  102.    from either regcomp or regexec.   We don't use PREG here.
  103.  
  104.  
  105. extern void regfree (regex_t *preg);
  106.  
  107.    Free dynamically allocated space used by PREG.
  108.  
  109.  
  110. (def-c-call-out regcomp (:arguments (preg (c-ptr regex_t) :out)
  111.                                     (pattern c-string)
  112.                                     (cflags int)
  113.                         )
  114.                         (:return-type int)
  115. )
  116. (def-c-call-out regexec (:arguments (preg (c-ptr regex_t))
  117.                                     (string c-string)
  118.                                     (nmatch size_t)
  119.                                     (pmatch (c-ptr (c-array regmatch_t 0)))
  120.                                     (eflags int)
  121.                         )
  122.                         (:return-type int)
  123. )
  124. (def-c-call-out regerror (:arguments (errcode int)
  125.                                      (preg (c-ptr regex_t))
  126.                                      (errbuf (c-ptr character))
  127.                                      (errbuf_size size_t)
  128.                          )
  129.                          (:return-type size_t)
  130. )
  131. (def-c-call-out regfree (:arguments (preg (c-ptr regex_t)))
  132.                         (:return-type nil)
  133. )
  134.  
  135. |#
  136.  
  137. ;; This interface is not exactly adapted to our needs. We introduce
  138. ;; slightly modified functions.
  139. #|
  140. extern int mregcomp (regex_t **ppreg, const char *pattern, int cflags);
  141. extern int regexec (const regex_t *preg, const char *string, size_t nmatch,
  142.                     regmatch_t pmatch[], int eflags);
  143. extern const char *mregerror (int errcode, const regex_t *preg);,
  144. extern void mregfree (regex_t *preg);
  145. |#
  146.  
  147. (eval-when (compile load eval) (defconstant num-matches 10))
  148. (def-c-call-out mregcomp (:arguments (ppreg (c-ptr regex_t-ptr) :out)
  149.                                      (pattern c-string)
  150.                                      (cflags int)
  151.                          )
  152.                          (:return-type int)
  153. )
  154. (def-c-call-out regexec (:arguments (preg regex_t-ptr)
  155.                                     (string c-string)
  156.                                     (nmatch size_t)
  157.                                     (pmatch (c-ptr (c-array regmatch_t #.num-matches)) :out)
  158.                                     (eflags int)
  159.                         )
  160.                         (:return-type int)
  161. )
  162. (def-c-call-out mregerror (:arguments (errcode int)
  163.                                       (preg regex_t-ptr)
  164.                           )
  165.                           (:return-type c-string :malloc-free)
  166. )
  167. (def-c-call-out mregfree (:arguments (preg regex_t-ptr))
  168.                          (:return-type nil)
  169. )
  170. ; cflags values
  171. (defconstant REG_EXTENDED 1)
  172. (defconstant REG_ICASE    2)
  173. (defconstant REG_NEWLINE  4)
  174. (defconstant REG_NOSUB    8)
  175. ; eflags values
  176. (defconstant REG_NOTBOL   1)
  177. (defconstant REG_NOTEOL   2)
  178.  
  179. ;; The following implementation of MATCH compiles the pattern once for every
  180. ;; search.
  181. (defun match-once (pattern string &key (start 0) (end nil) (case-insensitive nil))
  182.   ; Prepare the string.
  183.   (unless (and (eql start 0) (null end))
  184.     (unless end (setq end (length string)))
  185.     (setq string (make-array (- end start) :element-type 'string-char
  186.                                            :displaced-to string
  187.                                            :displaced-index-offset start
  188.   ) )            )
  189.   ; Compile the pattern.
  190.   (multiple-value-bind (errcode compiled-pattern)
  191.       (mregcomp pattern (if case-insensitive REG_ICASE 0))
  192.     (unless (zerop errcode)
  193.       (error "~S: ~A" 'match (mregerror errcode compiled-pattern))
  194.     )
  195.     ; Do the search.
  196.     (multiple-value-bind (errcode matches)
  197.         (regexec compiled-pattern string #.num-matches 0)
  198.       ; Free the compiled pattern.
  199.       (mregfree compiled-pattern)
  200.       ; Compute return values.
  201.       (if (zerop errcode)
  202.         (values-list ; the first value will be non-NIL
  203.           (map 'list (if (eql start 0)
  204.                        #'identity
  205.                        #'(lambda (match)
  206.                            (incf (regmatch_t-rm_so match) start)
  207.                            (incf (regmatch_t-rm_eo match) start)
  208.                            match
  209.                          )
  210.                      )
  211.                      (delete-if #'minusp matches :key #'regmatch_t-rm_so)
  212.         ) )
  213.         nil
  214. ) ) ) )
  215.  
  216. ;; The following implementation of MATCH compiles the pattern only once per
  217. ;; Lisp session, if it is a literal string.
  218. (defmacro match (pattern string &rest more-forms)
  219.   (if (stringp pattern)
  220.     `(%MATCH (MATCHER ,pattern) ,string ,@more-forms)
  221.     `(MATCH-ONCE ,pattern ,string ,@more-forms)
  222. ) )
  223. (defmacro matcher (pattern)
  224.   (declare (string pattern))
  225.   `(LOAD-TIME-VALUE (%MATCHER ,pattern))
  226. )
  227. (defun %matcher (pattern)
  228.   (list* pattern nil nil)
  229.   ; car = pattern,
  230.   ; cadr = compiled pattern, case sensitive,
  231.   ; cddr = compiled pattern, case insensitive.
  232. )
  233. (defun mregfree-finally (compiled-pattern)
  234.   (when (validp compiled-pattern) ; beware: compiled-pattern could come from a previous session
  235.     (mregfree compiled-pattern)
  236. ) )
  237. (defun %match (patternbox string &key (start 0) (end nil) (case-insensitive nil))
  238.   ; Compile the pattern, if not already done.
  239.   (let ((compiled-pattern (if case-insensitive (cddr patternbox) (cadr patternbox))))
  240.     (unless (and compiled-pattern (validp compiled-pattern))
  241.       (setq compiled-pattern
  242.         (multiple-value-bind (errcode compiled-pattern)
  243.             (mregcomp (car patternbox) (if case-insensitive REG_ICASE 0))
  244.           (unless (zerop errcode)
  245.             (error "~S: ~A" 'match (mregerror errcode compiled-pattern))
  246.           )
  247.           ; Arrange that when compiled-pattern is garbage-collected,
  248.           ; mregfree will be called.
  249.           (finalize compiled-pattern #'mregfree-finally)
  250.           (if case-insensitive
  251.             (setf (cddr patternbox) compiled-pattern)
  252.             (setf (cadr patternbox) compiled-pattern)
  253.     ) ) ) )
  254.     ; Prepare the string.
  255.     (unless (and (eql start 0) (null end))
  256.       (unless end (setq end (length string)))
  257.       (setq string (make-array (- end start) :element-type 'string-char
  258.                                              :displaced-to string
  259.                                              :displaced-index-offset start
  260.     ) )            )
  261.     ; Do the search.
  262.     (multiple-value-bind (errcode matches)
  263.         (regexec compiled-pattern string #.num-matches 0)
  264.       ; Compute return values.
  265.       (if (zerop errcode)
  266.         (values-list ; the first value will be non-NIL
  267.           (map 'list (if (eql start 0)
  268.                        #'identity
  269.                        #'(lambda (match)
  270.                            (incf (regmatch_t-rm_so match) start)
  271.                            (incf (regmatch_t-rm_eo match) start)
  272.                            match
  273.                          )
  274.                      )
  275.                      (delete-if #'minusp matches :key #'regmatch_t-rm_so)
  276.         ) )
  277.         nil
  278. ) ) ) )
  279.  
  280. (setf (fdefinition 'match-start) (fdefinition 'regmatch_t-rm_so))
  281. (setf (fdefinition '(setf match-start))
  282.       #'(lambda (new-value match) (setf (regmatch_t-rm_so match) new-value))
  283. )
  284.  
  285. (setf (fdefinition 'match-end) (fdefinition 'regmatch_t-rm_eo))
  286. (setf (fdefinition '(setf match-end))
  287.       #'(lambda (new-value match) (setf (regmatch_t-rm_eo match) new-value))
  288. )
  289.  
  290. ; Convert a match (of type regmatch_t) to a substring.
  291. (defun match-string (string match)
  292.   (let ((start (regmatch_t-rm_so match))
  293.         (end (regmatch_t-rm_eo match)))
  294.     (make-array (- end start) :element-type 'string-char
  295.                               :displaced-to string
  296.                               :displaced-index-offset start
  297. ) ) )
  298.  
  299. ; Utility function
  300. (defun regexp-quote (string)
  301.   (let ((qstring (make-array 10 :element-type 'string-char
  302.                                 :adjustable t :fill-pointer 0)))
  303.     (map nil #'(lambda (c)
  304.                  (case c
  305.                    ((#\$ #\^ #\. #\* #\[ #\] #\\) ; #\+ #\?
  306.                     (vector-push-extend #\\ qstring)
  307.                  ) )
  308.                  (vector-push-extend c qstring)
  309.                )
  310.              string
  311.     )
  312.     qstring
  313. ) )
  314.  
  315.